(in-package :cl-fast-ecs)


(define-global-var *component-registry* nil)
(define-global-var *component-registry-length* 0)

(defhook :component-defined
  :documentation
  "Called when a new component is defined with `DEFCOMPONENT` macro. Argument
for the call is the index in the component registry.

See `HOOK-UP`.")

(defhook :component-redefined
  :documentation
  "Called when an existing component is redefined with `DEFCOMPONENT` macro.
Argument for the call is the index in the component registry.

See `HOOK-UP`.")

(defhook :component-storage-grown
  :documentation
  "Called after the component storate capacity is increased due to the component
being added to the new entity. Arguments for the call are the index in the
component registry and the new storage capacity.

Note: this is a good place to call for a full GC cycle to collect old storage
arrays.

See `HOOK-UP`.")

(defgeneric make-component (index entity &key &allow-other-keys)
  (:documentation "Create a component on a given `ENTITY` in generic fashion.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives."))

(defgeneric delete-component (index entity)
  (:documentation "Deletes a component from a given `ENTITY` in generic fashion.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives."))

(defgeneric assign-component (index entity &key &allow-other-keys)
  (:documentation "An upsert operator which first ensures the component exists
on a given entity and then sets its values according to given keyword
arguments, but keeps slots that weren't specified to their previous values.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives."))

(defgeneric replace-component (index source-entity dest-entity)
  (:documentation "Copies component slot values from given `SOURCE-ENTITY` to
given `DEST-ENTITY` in generic fashion.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives."))

(defgeneric reset-component (index entity)
  (:documentation "Resets the values of component slots to their default values
for given `ENTITY`.

Not recommended for using in a tight loops such as systems, see `DEFCOMPONENT`
documentation for alternatives."))

(defgeneric print-component (index entity &optional stream)
  (:documentation "Prints component data to the given `STREAM`.

See `PRINT-ENTITY`."))

(declaim
 (ftype
  (function (symbol string list list list list list symbol list boolean) list)
  %soa-decl))
(defun %soa-decl (name documentation slot-names slot-defaults slot-types
                  slot-index slot-unique composite-index-name
                  composite-index-slots composite-index-unique)
  (declare (ignorable slot-unique composite-index-slots composite-index-unique))
  (let* ((struct-name (symbolicate name :-soa))
         (actual-struct-name (gentemp (string (the symbol struct-name))))
         (default-decls (mapcar #'list slot-names slot-defaults))
         #-ecs-release
         (soa-slots (mapcar (lambda (name type)
                              `(,name
                                :accessor
                                ,(symbolicate :% struct-name :- name)
                                :initform
                                (make-array
                                 *storage-entities-allocated*
                                 :initial-element
                                 ;; HACK for compilers that require
                                 ;; DEFSTRUCT to be on the toplevel
                                 ;; (looking at you, CCL)
                                 (let* (,@default-decls)
                                   (declare (ignorable ,@slot-names))
                                   ,name)
                                 :element-type ',type)
                                :type (simple-array ,type (*))
                                :slot-type ,type))
                            slot-names slot-types))
         #+ecs-release
         (soa-slots (mapcar (lambda (name type)
                              `(,name (make-array
                                       *storage-entities-allocated*
                                       :initial-element
                                       ;; HACK for compilers that require
                                       ;; DEFSTRUCT to be on the toplevel
                                       ;; (looking at you, CCL)
                                       (let* (,@default-decls)
                                         (declare (ignorable ,@slot-names))
                                         ,name)
                                       :element-type ',type)
                                      :type (simple-array ,type (*))))
                            slot-names slot-types))
         #-ecs-release
         (soa-index-slots
          (mapcar
           (lambda (name index unique type)
             (when index
               `(,(symbolicate name :-index)
                 :accessor ,(symbolicate :% struct-name :- name :-index)
                 :initform (make-array 0
                                       :element-type
                                       '(or null (simple-array fixnum (*)))
                                       :initial-element nil)
                 :type (simple-array (or null (simple-array fixnum (*))) (*))
                 :slot-type ,type
                 :slot-index ,name
                 :slot-index-unique ,unique)))
           slot-names slot-index slot-unique slot-types))
         #+ecs-release
         (soa-index-slots
          (mapcar
           (lambda (name index)
             (when index
               `(,(symbolicate name :-index)
                 (make-array 0
                             :element-type
                             '(or null (simple-array fixnum (*)))
                             :initial-element nil)
                 :type
                 (simple-array (or null (simple-array fixnum (*))) (*)))))
           slot-names slot-index))
         (adjust-decls (mapcar (lambda (name type)
                                 (let ((a (symbolicate
                                           :% struct-name :- name)))
                                   `(adjust-simple-arrayf
                                     (,a soa) new-size
                                     :element-type ',type
                                     :initial-element ,name)))
                               slot-names slot-types)))
    (declare (ignorable actual-struct-name))
    `(progn
       #-ecs-release
       (defclass ,struct-name (component-soa)
         (,@soa-slots ,@(remove nil soa-index-slots)
          ,@(when composite-index-name
              `((,(symbolicate composite-index-name :-index)
                 :accessor
                 ,(symbolicate :% struct-name :- composite-index-name :-index)
                 :initform
                 (make-array 0
                             :element-type '(or null (simple-array fixnum (*))))
                 :type (simple-array (or null (simple-array fixnum (*))) (*))
                 :slot-type (list ,@(mapcar
                                     (lambda (s)
                                       (nth (position s slot-names :test #'eq)
                                            slot-types))
                                     composite-index-slots))
                 :slot-composite-index ,composite-index-slots
                 :slot-composite-index-unique ,composite-index-unique))))
         (:metaclass component-soa-class)
         (:documentation ,documentation))
       #+(and (not ecs-release) (or allegro ecl))
       (make-instances-obsolete ',struct-name)
       #+ecs-release
       (defstruct (,actual-struct-name
                   (:conc-name ,(symbolicate :% struct-name :-))
                   (:constructor ,(symbolicate :%make- struct-name))
                   (:copier nil)
                   (:predicate nil)
                   (:include component-soa))
         ,documentation
         ,@soa-slots ,@(remove nil soa-index-slots)
         ,@(when composite-index-name
             `((,(symbolicate composite-index-name :-index)
                (make-array 0
                            :element-type '(or null (simple-array fixnum (*))))
                :type (simple-array (or null (simple-array fixnum (*))) (*))))))
       (declaim (ftype (function (#-ecs-release ,struct-name
                                  #+ecs-release ,actual-struct-name
                                  array-length))
                       ,(symbolicate :%adjust- struct-name)))
       (defun ,(symbolicate :%adjust- struct-name) (soa new-size)
         (declare (optimize (safety 0)))
         (let* (,@default-decls)
           ,@adjust-decls)
         (setf (component-soa-allocated soa) new-size))
       nil)))

(declaim (inline %non-unique-error))
(defun %non-unique-error (name values slots)
  (let ((composite-p (and (second values) t)))
    (error
     "~:[Value~;Tuple~] ~{~s~^, ~} is not unique among ~a values ~{~a~^, ~}"
     composite-p values name slots)))

(declaim
 (ftype
  (function (symbol symbol symbol symbol symbol (or null symbol) boolean) list)
  %update-index))
(defun %update-index (name slot soa data value index unique)
  (when index
    `(let ((index (,(symbolicate :% name :-soa- slot :-index) ,soa)))
       (declare (type (simple-array (or null (simple-array fixnum (*))) (*))
                      index))
       (index-delete index entity ((aref ,data entity)))
       ,(if unique
            `(when (index-insert index (,data) entity (,value) t)
               (%non-unique-error ',name (list ,value) '(,slot)))
            `(index-insert index (,data) entity (,value) nil)))))

(declaim (ftype
          (function (symbol symbol symbol symbol list list symbol list boolean
                            &rest list)
                    list)
  %update-composite-index))
(defun %update-composite-index (name slot soa value slot-names slot-types
                                composite-index-name composite-index-slots
                                composite-index-unique &rest body)
  (if composite-index-name
      (let* ((data-names (make-gensym-list (length composite-index-slots)))
             (values (mapcar (lambda (d s) (if (eq s slot) value `(aref ,d entity)))
                             data-names composite-index-slots)))
        `(let ((index (,(symbolicate :% name :-soa- composite-index-name :-index)
                       ,soa))
               ,@(mapcar (lambda (n s type)
                           `(,n (the (simple-array ,type)
                                     (,(symbolicate :% name :-soa- s) ,soa))))
                         data-names composite-index-slots
                         (map 'list
                              (lambda (s)
                                (declare (type symbol s))
                                (nth (the array-index (position s slot-names))
                                     slot-types))
                              composite-index-slots)))
           (declare (type (simple-array (or null (simple-array fixnum (*))) (*))
                          index))
           (index-delete index entity
               ,(mapcar (lambda (d) `(aref ,d entity)) data-names))
           (progn ,@body)
           ,(if composite-index-unique
                `(when (index-insert index ,data-names entity ,values t)
                   (%non-unique-error ',name (list ,@values)
                                      ',composite-index-slots))
                `(index-insert index ,data-names entity ,values nil))))
      `(progn ,@body)))

(declaim
 (ftype (function (symbol symbol symbol symbol list list list list list list)
                  list)
        %update-generated-slots))
(defun %update-generated-slots (name slot soa value slot-names slot-defaults
                                slot-types slot-index slot-unique
                                slot-generated-from)
  (let ((default-decls
          (mapcar
           #'(lambda (n type)
               (list n (if (eq n slot)
                           value
                           `(aref (the (simple-array ,type)
                                       (,(symbolicate :% name :-soa- n) ,soa))
                                  entity))))
           slot-names slot-types)))
    (mapcan
     (lambda (n d type i u g)
       (when (find slot g :test #'eq)
         (let ((slot-accessor-name (symbolicate :% name :-soa- n)))
           `(let ((data (the (simple-array ,type)
                             (,slot-accessor-name ,soa))))
              (setf (aref data entity)
                    (let* (,@(remove n default-decls :key #'car :test #'eq))
                      (declare (ignorable ,@(remove n slot-names)))
                      ,d))
              ,(%update-index name n soa 'data value i u)))))
     slot-names slot-defaults slot-types slot-index slot-unique slot-generated-from)))

(declaim (ftype (function (symbol symbol list list list list list list list
                                  symbol list boolean)
                          list)
                %accessor-decls))
(defun %accessor-decls (name index-var-name slot-names slot-defaults slot-types
                        slot-docs slot-index slot-unique slot-generated-from
                        composite-index-name composite-index-slots
                        composite-index-unique)
  (mapcan
   (lambda (n type doc i u g)
     (let ((accessor-name (symbolicate name :- n))
           (slot-accessor-name (symbolicate :% name :-soa- n)))
       `((declaim #+ecs-release (inline ,accessor-name (setf ,accessor-name))
                  (ftype (function (entity) ,type) ,accessor-name)
                  ,@(unless g
                      `((ftype (function (,type entity) ,type)
                               (setf ,accessor-name)))))
         (defun ,accessor-name (entity)
           ,doc
           (with-storage ()
             (let* ((component-storages (storage-component-storages storage))
                    (soa (svref component-storages ,index-var-name)))
               (aref (the (simple-array ,type) (,slot-accessor-name soa))
                     entity))))
         ,@(unless g
             `((defun (setf ,accessor-name) (value entity)
                 ,doc
                 (with-storage ()
                   (let* ((component-storages
                            (storage-component-storages storage))
                          (soa (svref component-storages ,index-var-name))
                          (data (the (simple-array ,type)
                                     (,slot-accessor-name soa))))
                     ,(%update-index name n 'soa 'data 'value i u)
                     ,(%update-composite-index
                       name n 'soa 'value slot-names slot-types
                       composite-index-name composite-index-slots
                       composite-index-unique
                       (%update-generated-slots
                        name n 'soa 'value slot-names slot-defaults slot-types
                        slot-index slot-unique slot-generated-from))
                     (setf (aref data entity) value)))))))))
   slot-names slot-types slot-docs slot-index slot-unique slot-generated-from))

(declaim
 (ftype (function
         (symbol symbol list list list list list list symbol list boolean) list)
        %ctor-decl))
(defun %ctor-decl (name index-var-name slot-names slot-defaults slot-types
                   slot-index slot-unique slot-generated-from
                   composite-index-name composite-index-slots
                   composite-index-unique)
  (with-gensyms (entity)
    `(defun ,(symbolicate :make- name) (,entity
                                        &key ,@(remove
                                                nil
                                                (mapcar (lambda (n d g)
                                                          (unless g
                                                            (list n d)))
                                                        slot-names slot-defaults
                                                        slot-generated-from))
                                        &aux ,@(remove
                                                nil
                                                (mapcar (lambda (n d g)
                                                          (when g
                                                            `(,n ,d)))
                                                        slot-names slot-defaults
                                                        slot-generated-from)))
       (declare ,@(mapcar (lambda (slot type) `(type ,type ,slot))
                          slot-names slot-types))
       ,(format nil "Add ~a component with given values to an entity." name)
       (with-storage ()
         (with-checked-entity ,entity
           (let* ((component-storages (storage-component-storages storage))
                  (soa (svref component-storages ,index-var-name)))
             (if (zerop (sbit (component-soa-exists soa) ,entity))
                 (block new
                   (when (>= ,entity (component-soa-allocated soa))
                     (let ((new-size (new-capacity (1+ ,entity))))
                       (,(symbolicate :%adjust- name :-soa) soa new-size)
                       (run-hook *component-storage-grown-hook*
                                 ,index-var-name new-size)))
                   (incf (component-soa-count soa))
                   ,@(remove
                      nil
                      (mapcar
                       (lambda (s type i u)
                         (when i
                           `(let ((index
                                    (,(symbolicate :% name :-soa- s :-index)
                                     soa))
                                  (data
                                    (the (simple-array ,type)
                                         (,(symbolicate :% name :-soa- s)
                                          soa))))
                              (declare
                               (type
                                (simple-array
                                 (or null (simple-array fixnum (*))) (*))
                                index))
                              (when-let (new-index
                                         (index-maybe-grow
                                             index
                                             (component-soa-count soa)
                                             (data)
                                             (component-soa-exists soa)
                                             (component-soa-min-entity soa)
                                             (component-soa-max-entity soa)))
                                (setf
                                 index new-index
                                 (,(symbolicate :% name :-soa- s :-index) soa)
                                 new-index))
                              ,(if u
                                   `(when (index-insert index
                                              (data) ,entity (,s) t)
                                      (%non-unique-error
                                       ',name (list ,s) '(,s)))
                                   `(index-insert index
                                        (data) ,entity (,s) nil)))))
                       slot-names slot-types slot-index slot-unique))
                   ,(when composite-index-name
                      (let ((data-names (make-gensym-list
                                         (length composite-index-slots))))
                        `(let ((index
                                 (,(symbolicate
                                    :% name :-soa- composite-index-name :-index)
                                  soa))
                               ,@(mapcar
                                   (lambda (n s type)
                                     `(,n (the (simple-array ,type)
                                               (,(symbolicate :% name :-soa- s)
                                                soa))))
                                   data-names
                                   composite-index-slots
                                   (map 'list
                                        (lambda (s)
                                          (declare (type symbol s))
                                          (nth (the array-index
                                                    (position s slot-names))
                                               slot-types))
                                        composite-index-slots)))
                           (declare
                            (type
                             (simple-array
                              (or null (simple-array fixnum (*))) (*))
                             index))
                           (when-let (new-index
                                      (index-maybe-grow
                                          index
                                          (component-soa-count soa)
                                          ,data-names
                                          (component-soa-exists soa)
                                          (component-soa-min-entity soa)
                                          (component-soa-max-entity soa)))
                             (setf
                              index new-index
                              (,(symbolicate
                                 :% name :-soa- composite-index-name :-index)
                               soa)
                              new-index))
                           ,(if composite-index-unique
                                `(when (index-insert index ,data-names ,entity
                                           ,composite-index-slots t)
                                   (%non-unique-error
                                    ',name (list ,@composite-index-slots)
                                    ',composite-index-slots))
                                `(index-insert index ,data-names ,entity
                                     ,composite-index-slots nil)))))
                   (when (< ,entity (component-soa-min-entity soa))
                     (setf (component-soa-min-entity soa) ,entity))
                   (when (> ,entity (component-soa-max-entity soa))
                     (setf (component-soa-max-entity soa) ,entity))
                   (setf (sbit (component-soa-exists soa) ,entity) 1
                         (sbit (storage-component-created-bits storage)
                               ,index-var-name) 1))
                 (block exists
                   #-ecs-release
                   (warn "component ~a already exists on entity ~a"
                         ',name ,entity)))
             (setf ,@(mapcan
                      (lambda (s d type g)
                        `((aref (the (simple-array ,type)
                                     (,(symbolicate :% name :-soa- s) soa))
                                ,entity)
                          ,(if g d s)))
                      slot-names slot-defaults slot-types slot-generated-from)))
           nil)))))

(declaim
 (ftype
  (function (symbol symbol list list list (or null cons) list symbol list) list)
  %dtor-decl))
(defun %dtor-decl (name index-var-name slot-names slot-defaults slot-types
                   finalize slot-index composite-index-name
                   composite-index-slots)
  (with-gensyms (storage)
    (let ((default-decls (mapcar #'list slot-names slot-defaults)))
      `(let* (,@default-decls)
         (declare (ignorable ,@slot-names))
         (defun ,(symbolicate :delete- name) (entity)
           ,(format nil "Remove the ~a component from the given ENTITY." name)
           (with-storage (,storage)
             (with-checked-entity entity
               (let* ((component-storages (storage-component-storages ,storage))
                      (soa (svref component-storages ,index-var-name)))
                 ,(when finalize
                    `(funcall ,finalize
                              entity
                              ,@(mapcan
                                 (lambda (s type)
                                   `(,(make-keyword s)
                                     (aref (the (simple-array ,type)
                                                (,(symbolicate
                                                   :% name :-soa- s)
                                                 soa))
                                           entity)))
                                 slot-names slot-types)))
                 ,@(remove nil
                           (mapcar
                            (lambda (s type index)
                              (when index
                                `(index-delete
                                     (the
                                      (simple-array
                                       (or null (simple-array fixnum (*)))
                                       (*))
                                      (,(symbolicate :% name :-soa- s :-index)
                                       soa))
                                     entity
                                     ((aref (the (simple-array ,type)
                                                 (,(symbolicate
                                                    :% name :-soa- s)
                                                  soa))
                                            entity)))))
                            slot-names slot-types slot-index))
                 ,(when composite-index-name
                    `(index-delete
                         (the (simple-array (or null (simple-array fixnum (*)))
                                            (*))
                              (,(symbolicate :% name :-soa- composite-index-name
                                             :-index)
                               soa))
                         entity
                         ,(mapcar
                           (lambda (s type)
                             `(aref (the (simple-array ,type)
                                         (,(symbolicate :% name :-soa- s)
                                          soa))
                                    entity))
                           composite-index-slots
                           (map 'list
                                (lambda (s)
                                  (declare (type symbol s))
                                  (nth (the array-index
                                            (position s slot-names))
                                       slot-types))
                                composite-index-slots))))
                 (decf (component-soa-count soa))
                 (setf (sbit (component-soa-exists soa) entity) 0
                       (sbit (storage-component-removed-bits ,storage)
                             ,index-var-name) 1
                             #-ecs-release
                             ,@(mapcan
                                (lambda (s type)
                                  `((aref
                                     (the (simple-array ,type)
                                          (,(symbolicate :% name :-soa- s)
                                           soa))
                                     entity) ,s))
                                slot-names slot-types)))
               nil)))))))

(declaim (inline format-symbol/component))
(defun format-symbol/component (component control &rest args)
  (let* ((package (symbol-package component))
         (shadowing (member component (package-shadowing-symbols *package*))))
    (apply #'format-symbol
           (if (or shadowing (eq package (find-package :common-lisp)))
               t
               package)
           control
           args)))

(declaim
 (ftype (function
         (symbol symbol list list list list list list symbol list boolean) list)
        %with-macro-decl))
(defun %with-macro-decl (name index-var-name slot-names slot-defaults slot-types
                         slot-index slot-unique slot-generated-from
                         composite-index-name composite-index-slots
                         composite-index-unique)
  (let ((slot-gensyms (mapcar (lambda (s) (declare (type symbol s))
                                (gensym (string s)))
                              slot-names)))
    `(defmacro ,(symbolicate :%with- name :-slots)
         (bindings readonly component-storages entity &body body)
       (with-gensyms (soa)
         (let* ((soa-slot-bindings
                  (mapcar (lambda (n s type)
                            `(,n (the (simple-array ,type)
                                      (,(format-symbol/component
                                         ',name "%~a-SOA-~a" ',name s)
                                       ,soa))))
                          ',slot-gensyms ',slot-names ',slot-types))
                (accessor-names
                  (mapcar (lambda (s) (gentemp (format nil "%~a" s)))
                          ',slot-names))
                (setter-names (remove nil
                                      (mapcar (lambda (n g) (unless g `(setf ,n)))
                                              accessor-names
                                              ',slot-generated-from)))
                (accessor-bindings
                  (mapcan
                   (lambda (n s slot type i u g)
                     `((,n (entity) (aref ,s entity))
                       ,@(when #-ecs-release (not (or g readonly))
                               #+ecs-release t
                               `(((setf ,n) (v entity)
                                  (declare (ignorable v entity)
                                           (type ,type v))
                                  ,(if (or g readonly)
                                       `(error "~a slot ~a is readonly"
                                               ',',name ',slot)
                                       `(progn
                                          ,(%update-index
                                            ',name slot soa s 'v i u)
                                          ,(%update-composite-index
                                            ',name slot soa 'v
                                            ',slot-names ',slot-types
                                            ',composite-index-name
                                            ',composite-index-slots
                                            ,composite-index-unique
                                            (%update-generated-slots
                                             ',name slot soa 'v ',slot-names
                                             ',slot-defaults ',slot-types
                                             ',slot-index ',slot-unique
                                             ',slot-generated-from))
                                          (setf (aref ,s entity) v))))))))
                   accessor-names ',slot-gensyms ',slot-names ',slot-types
                   ',slot-index ',slot-unique ',slot-generated-from))
                (binding-names (or bindings
                                   (mapcar (lambda (n) (symbolicate ',name :- n))
                                           ',slot-names)))
                (slot-bindings
                  (mapcar (lambda (n a) `(,n (,a ,entity)))
                          binding-names accessor-names)))
           `(let* ((,soa (svref ,component-storages ,',index-var-name))
                   ,@soa-slot-bindings)
              (declare (ignorable ,soa ,@',slot-gensyms)
                       #+sbcl (sb-ext:muffle-conditions
                               sb-ext:code-deletion-note))
              (flet (,@accessor-bindings)
                (declare (inline ,@accessor-names
                                 ,@(unless readonly setter-names))
                         #+sbcl (sb-ext:unmuffle-conditions
                                 sb-ext:code-deletion-note)
                         #+clasp (ignorable ,@accessor-names ,@setter-names))
                (symbol-macrolet (,@slot-bindings)
                  ,@(if #+ecs-release nil
                        #-ecs-release (or
                                       ',(some #'identity slot-generated-from)
                                       readonly)
                        `((handler-case (progn ,@body)
                            (undefined-function (u)
                              (let ((f (cell-error-name u)))
                                (if (and (eq (first f) 'setf)
                                         (find (second f)
                                               ',binding-names :test #'eq))
                                    (error "~a slot ~a is readonly"
                                           ',',name (second f))
                                    (error u))))))
                        body)))))))))

(declaim
 (ftype (function (symbol symbol symbol symbol (or symbol cons) symbol boolean)
                  list)
        %index-accessor-decls))
(defun %index-accessor-decls (component-name index-var-name struct-name name
                              type index unique)
  (when index
    (if unique
        `(progn
           (declaim
            (ftype (function (,type &key (:missing-error-p boolean)) entity)
                   ,index))
           (defun ,index (value &key (missing-error-p t))
             (with-storage ()
               (let* ((component-storages (storage-component-storages storage))
                      (soa (svref component-storages ,index-var-name))
                      (data (,(symbolicate :% struct-name :- name) soa)))
                 (declare (type (simple-array ,type) data))
                 (if-let (entity (index-lookup-1
                                     (,(symbolicate
                                        :% struct-name :- name :-index)
                                      soa)
                                     (data) (value)))
                   entity
                   (if missing-error-p
                       (error "There is no entity with ~a ~a ~a"
                              ',component-name ',name value)
                       -1))))))
        `(progn
           (declaim (ftype (function (,type &key (:count array-length)
                                            (:start array-index)) list) ,index))
           (defun ,index (value &key (count (- array-dimension-limit 2))
                                     (start 0))
             (with-storage ()
               (let* ((component-storages (storage-component-storages storage))
                      (soa (svref component-storages ,index-var-name))
                      (data (,(symbolicate :% struct-name :- name) soa)))
                 (declare (type (simple-array ,type) data))
                 (index-lookup
                     (,(symbolicate :% struct-name :- name :-index) soa)
                     (data) (value) count start))))
           (defmacro ,(symbolicate :with- index) (value entity &body body)
             (once-only (value)
               (with-gensyms (component-storages soa data)
                 `(with-storage ()
                    (let* ((,component-storages
                             (storage-component-storages storage))
                           (,soa (svref ,component-storages ,',index-var-name))
                           (,data (,(symbolicate :% ',struct-name :- ',name)
                                   ,soa)))
                      (declare (type (simple-array ,',type) ,data))
                      (index-enumerate
                          (,(symbolicate
                             :% ',struct-name :- ',name :-index) ,soa)
                          (,data) (,value) ,entity ,@body))))))))))

(declaim (ftype (function (symbol symbol list boolean list list list) list)
                %composite-index-accessor-decls))
(defun %composite-index-accessor-decls (name struct-name slots unique
                                        slot-names slot-defaults slot-types)
  (let* ((composite-index-slot-types
           (map 'list
                (lambda (s)
                  (declare (type symbol s))
                  (nth (position s slot-names) slot-types))
                slots))
         (keyword-decls (mapcar (lambda (n type) (list (make-keyword n) type))
                                slots composite-index-slot-types))
         (keyword-supplied (mapcar (lambda (n) (symbolicate n :-supplied-p))
                                   slots))
         (default-decls (mapcar #'list slot-names slot-defaults))
         (keyword-args (mapcar (lambda (n s)
                                 `(,n (let* (,@default-decls)
                                        (declare (ignorable ,@slot-names))
                                        ,n)
                                      ,s))
                               slots keyword-supplied))
         (index-var-name (format-symbol :cl-fast-ecs "+~a-COMPONENT-INDEX+"
                                        struct-name))
         (data-names (make-gensym-list (length slots)))
         (data-bindings (mapcar
                         (lambda (d s type)
                           `(,d
                             (the (simple-array ,type)
                                  (,(symbolicate :% struct-name :-soa- s)
                                   soa))))
                         data-names slots composite-index-slot-types)))
    (when name
      (when (and unique (find :missing-error-p slot-names :test #'string=))
        (error
         "Unsupported slot name for the composite index: MISSING-ERROR-P"))
      (when (and (not unique) (find :count slot-names :test #'string=))
        (error
         "Unsupported slot name for the composite index: COUNT"))
      (when (and (not unique) (find :start slot-names :test #'string=))
        (error
         "Unsupported slot name for the composite index: START"))
      `(progn
         (declaim
          (ftype (function (&key ,@(when unique
                                     `((:missing-error-p boolean)))
                                 ,@(unless unique
                                     `((:count array-length)
                                       (:start array-index)))
                                 ,@keyword-decls)
                           ,(if unique 'entity 'list))
                 ,name))
         (defun ,name (&key ,@(when unique
                                `((missing-error-p t)))
                            ,@(unless unique
                                `((count (- array-dimension-limit 2))
                                  (start 0)))
                            ,@keyword-args)
           (unless (and ,@keyword-supplied)
             (error
              "Missing slot values in composite index accessor: ~{~a~^, ~}"
              (let ((keyword-supplied (list ,@keyword-supplied)))
                (declare (dynamic-extent keyword-supplied))
                (loop :for s :of-type boolean :in keyword-supplied
                      :for n :of-type symbol :in ',slots
                      :unless s :collect n))))
           (with-storage ()
             (let* ((component-storages (storage-component-storages storage))
                    (soa (svref component-storages ,index-var-name))
                    ,@data-bindings
                    (result (,(if unique 'index-lookup-1 'index-lookup)
                             (,(symbolicate :% struct-name :-soa- name :-index)
                              soa)
                             ,data-names ,slots
                             ,@(unless unique
                                 '(count start)))))
               (declare (type ,(if unique '(or entity null) 'list) result))
               ,(if unique
                    `(if result result
                         (if missing-error-p
                             (error
                              "There is no entity with ~a ~{~a~^, ~} = ~{~a~^, ~}"
                              ',struct-name ',slots (list ,@slots))
                             -1))
                    `result))))))))

(defmacro defcomponent (name* &rest slots*)
  "Defines component structure with `NAME` and `SLOTS`, allowing optional
docstring, just like `DEFSTRUCT`.

There's extra keyword argument `:INDEX` to the slot definition, which, if set
to symbol, creates a function referencing a hash table-based index for that
slot allowing fast (amort. *O(1)*) lookups in form of \"which set of entities
have this exact slot value\"; that might come in handy when implementing
parent/child or other entity relationships. The downside of such index is that
component add/delete/update operations take a little bit longer, and addition
can trigger expensive table rehashing.

Additionally, when `:UNIQUE` is set to `T`, such index ensures that entities
and given slot values map 1 to 1, at least in value's `SXHASH` sense. This
might prove valuable when implementing entity names.

The index function always returns entities in strictly ascending order. It also
takes optional keyword arguments `START` and `COUNT` allowing to limit the
returned list of entities.

In addition, a `WITH-name` macro is defined for every index, allowing to
iterate over entities in index without extra consing. Note that deleting
entities from index while iterating with that macro is bad idea as it will lead
to subtle logic errors.

There's also `:GENERATED-FROM` argument to the slot definition, which, if set
to the list of slot names, creates a generated slot akin to `GENERATED STORED`
columns found in some relational databases. The value of such slot is
calculated using its default expression, and is automatically recalculated
when any of the slots specified in `:GENERATED-FROM` list are changed. Setting
its value directly is impossible. A generated column could also be a part of
an index.

The `NAME` argument could also be a lambda list of form
`(NAME ＆KEY FINALIZE COMPOSITE-INDEX)`. `FINALIZE` is a designator of function
that'd be called when the entity with the component is deleted. It should take
entity as the first argument and component slot values as keyword arguments
with corresponding names. `COMPOSITE-INDEX` is lambda list of form
`(NAME SLOTS ＆KEY UNIQUE)`, which defines a composite index, i.e. index
similar to single-slot index described above, but spawning several slots at
once, supplied as `SLOTS` list. Composite index name cannot be the same as any
slot name.

To be called from a top-level. Allows redefinition of component with the same
`NAME` but different set of `SLOT`s; all necessary storage will be properly
reallocated.

This macro defines a following set of operations for given `NAME`:

* an internal structure called `name-SOA` with its required internal machinery;
* a constant `+name-COMPONENT-INDEX+` to reference component data within a
storage;
* a component data accessors `name-slotName` and
`(SETF name-slotName)` for every slot on a component, with *O(1)*
complexity (their usage is discouraged though because of poor caching
performance, in favour of defining a new system with `DEFSYSTEM`);
* a component constructor aptly named `MAKE-name`, which adds the component
being defined to the given `ENTITY`, with *O(k)* complexity, where *k* is the
number of slots on the component. Note that trying to construct the component
on an entity which already has that component is not an error, but produces
warning when not in release mode;
* specialization of `MAKE-COMPONENT` generic on a component being defined;
* a predicate called `HAS-name-P` testing whether given `ENTITY` has the
component being defined, with *O(1)* complexity;
* a component destructor called `DELETE-name`, removing the component being
defined from the given `ENTITY` in *O(k)* complexity,where *k* is the number
of slots on the component;
* specialization of `DELETE-COMPONENT` generic on a component being defined;
* a convenience macro `WITH-name` akin to `WITH-SLOTS`;
* an upsert operator `ASSIGN-name` which first ensures the component exists
on given entity and then sets its values according to given keyword arguments,
but keeps slots that weren't specified to their previous values;
* specialization of `ASSIGN-COMPONENT` generic on a component being defined;
* a `REPLACE-name` function which copies the component slot values from one
given entity to another;
* a `RESET-name` function which sets component slot values to their default
values for given entity;
* specialization of `RESET-COMPONENT` generic on a component being defined;
* a `name-COUNT` helper function with no arguments which returns the current
count of entities having this component;
* some internal helper macros;
* if `:INDEX` if set to a symbol for any slot, the function with the name
denoted by that symbol is defined, taking slot value as an argument and
returning the list of entities having such slot value;
* if `:UNIQUE` is specified and set to `T` in addition to `:INDEX`, the index
function returns a single entity having given slot value, or raises a condition
if there's no such entity. If the `:MISSING-ERROR-P` keyword argument to that
function is `NIL`, no condition is raised, but negative entity is returned
instead.

Also runs hook `*COMPONENT-DEFINED-HOOK*` or `*COMPONENT-REDEFINED-HOOK*` when
called, depending on circumstances."
  (let* ((name (if (symbolp name*) name* (first name*)))
         finalize*
         composite-index-name composite-index-slots composite-index-unique
         (has-documentation-p (typep (first slots*) 'string))
         (documentation (if has-documentation-p (first slots*) ""))
         (slots (if has-documentation-p (rest slots*) slots*))
         (struct-name (symbolicate name :-soa))
         (slot-names (mapcar #'car slots))
         (slot-defaults (mapcar #'cadr slots))
         (slot-types (mapcar (lambda (s) (getf s :type t)) slots))
         (slot-index (mapcar (lambda (s) (getf s :index nil)) slots))
         (slot-unique (mapcar (lambda (s) (getf s :unique nil)) slots))
         (slot-generated-from
           (mapcar #'(lambda (s) (getf s :generated-from nil)) slots))
         (_ (unless (every (lambda (i u) (or i (not u))) slot-index slot-unique)
              (error "The :UNIQUE argument requires :INDEX to be set")))
         (slot-docs (mapcar (lambda (s) (getf s :documentation "")) slots))
         (index-var-name (format-symbol :cl-fast-ecs "+~a-COMPONENT-INDEX+"
                                        name)))
    (declare (ignore _)
             (type list composite-index-slots))
    (loop
     :for slot-name :in slot-names
     :for slot-type :in slot-types
     :do (cond
           ((or (subtypep slot-type 'string)
                (subtypep slot-type 'symbol)
                (subtypep slot-type 'function)
                (and (symbolp slot-type)
                     (string= slot-type 'foreign-pointer)))
            ;; NOTE: those types indeed are boxed, but no need to rub it in
            nil)
           ((or (subtypep slot-type 'array)
                (subtypep slot-type 'sequence))
            (uiop:style-warn
             "~a values will be boxed; consider using separate entities instead"
             slot-name))
           ((subtypep slot-type 'hash-table)
            (uiop:style-warn
             "~a values will be boxed; consider using slot index instead"
             slot-name))
           ((eq t (upgraded-array-element-type slot-type))
            (uiop:style-warn
             "~a values will be boxed; consider using primitive type"
             slot-name))))
    (unless (symbolp name*)
      (destructuring-bind (n &key finalize composite-index) name*
        (declare (ignore n))
        (setf finalize* finalize)
        (when composite-index
          (destructuring-bind (name slots &key unique) composite-index
            (setf composite-index-name name
                  composite-index-slots slots
                  composite-index-unique unique)
            (assert
             (> (length composite-index-slots) 1)
             (composite-index-slots)
             "Composite index requires >= 2 slots, got ~a instead (~{~a~^, ~})"
             (length composite-index-slots)
             composite-index-slots)
            (assert
             (not (set-difference composite-index-slots slot-names))
             (composite-index-slots)
             "Unknown slot(s): ~{~a~^, ~}"
             (nreverse (set-difference composite-index-slots slot-names)))))))
    `(progn
       (eval-when (#+ecs-release :compile-toplevel :load-toplevel :execute)
         ,(%soa-decl name documentation slot-names slot-defaults slot-types
                     slot-index slot-unique composite-index-name
                     composite-index-slots composite-index-unique))
       (eval-when (:compile-toplevel :load-toplevel :execute)
         #+abcl (declaim (special ,index-var-name))
         (unless (boundp ',index-var-name)
           (declaim (type array-index ,index-var-name))
           (defconstant ,index-var-name *component-registry-length*)
           (incf *component-registry-length*))
         (setf (getf *component-registry* ,(make-keyword name))
               #-ecs-release ',struct-name
               #+ecs-release #',(symbolicate :%make- struct-name)))
       (run-hook (if (boundp ',index-var-name)
                     *component-redefined-hook*
                     *component-defined-hook*)
                 ,index-var-name)
       ,@(%accessor-decls name index-var-name slot-names slot-defaults
                          slot-types slot-docs slot-index slot-unique
                          slot-generated-from composite-index-name
                          composite-index-slots composite-index-unique)
       ,(%ctor-decl name index-var-name slot-names slot-defaults slot-types
                    slot-index slot-unique slot-generated-from
                    composite-index-name composite-index-slots
                    composite-index-unique)
       ,(with-gensyms (entity)
          `(defmethod make-component ((index (eql ,index-var-name)) ,entity
                                      &rest args
                                      &key ,@(remove
                                              nil
                                              (mapcar (lambda (n d g)
                                                        (unless g
                                                          (list n d)))
                                                      slot-names slot-defaults
                                                      slot-generated-from)))
             (declare (ignorable ,@(remove nil (mapcar
                                                (lambda (n g)
                                                  (unless g
                                                    n))
                                                slot-names
                                                slot-generated-from))))
             ,(format nil "Creates a ~a component on a given ENTITY." name)
             (apply #',(symbolicate :make- name) ,entity args)))
       (declaim (ftype (function (entity) boolean)
                       ,(symbolicate :has- name :-p)))
       (defun ,(symbolicate :has- name :-p) (entity)
         ,(format nil "Test whether given ENTITY has the ~a component." name)
         (with-storage ()
           (with-checked-entity entity
             (let* ((component-storages (storage-component-storages storage))
                    (soa (svref component-storages ,index-var-name)))
               (not (zerop (sbit (component-soa-exists soa) entity)))))))
       (declaim (ftype (function (entity))
                       ,(symbolicate :delete- name)))
       ,(%dtor-decl name index-var-name slot-names slot-defaults slot-types
                    finalize* slot-index composite-index-name
                    composite-index-slots)
       (defmethod delete-component ((index (eql ,index-var-name)) entity)
         ,(format nil "Deletes a ~a component from given ENTITY." name)
         (funcall #',(symbolicate :delete- name) entity))
       ,(%with-macro-decl name index-var-name slot-names slot-defaults
                          slot-types slot-index slot-unique slot-generated-from
                          composite-index-name
                          composite-index-slots composite-index-unique)
       (defmacro ,(symbolicate :with- name) (bindings entity &body body)
         ,(format nil "A convenience macro to access entity's ~a component data.
Prefer DEFSYSTEM to access the component data though." name)
         (with-gensyms (entity-var)
           (let ((internal-macro ',(symbolicate :%with- name :-slots))
                 (slot-names ',slot-names))
             `(let ((,entity-var ,entity))
                (with-storage ()
                  (with-checked-entity ,entity-var
                    (,internal-macro ,(cond ((eq bindings t) nil)
                                            (bindings bindings)
                                            (t slot-names))
                                     nil
                                     (storage-component-storages storage)
                                     ,entity-var
                                     ,@body)))))))
       ,(with-gensyms (entity)
          `(defun ,(symbolicate :assign- name)
               (,entity
                &rest args
                &key ,@(remove
                        nil
                        (mapcar (lambda (n d g)
                                  (unless g
                                    (list n d (symbolicate n :-supplied-p))))
                                slot-names slot-defaults slot-generated-from)))
             ,(format nil "Creates or updates the ~a component." name)
             (with-storage ()
               (with-checked-entity ,entity
                 (let* ((component-storages
                          (storage-component-storages storage))
                        (soa (svref component-storages ,index-var-name)))
                   (declare (ignorable soa))
                   (if (zerop (sbit (component-soa-exists soa) ,entity))
                       (apply #',(symbolicate :make- name) ,entity args)
                       ,(let ((slot-names* (mapcar (compose 'gensym 'string)
                                                   slot-names)))
                          `(,(symbolicate :%with- name :-slots) ,slot-names* nil
                            component-storages ,entity
                            ,@(mapcar (lambda (n* n g)
                                        (unless g
                                          `(when ,(symbolicate n :-supplied-p)
                                             (setf ,n* ,n))))
                                      slot-names* slot-names
                                      slot-generated-from)
                            nil))))))))
       (defmethod assign-component ((index (eql ,index-var-name)) entity
                                    &rest slots)
         ,(format nil "Creates or updates the ~a component." name)
         (apply #',(symbolicate :assign- name) entity slots))
       ,@(when (every #'null slot-unique)
          `((defun ,(symbolicate :replace- name) (dst-entity src-entity)
              (with-storage ()
                (with-checked-entity dst-entity
                  (with-checked-entity src-entity
                    (,(symbolicate :%with- name :-slots) ,slot-names t
                     (storage-component-storages storage)
                     src-entity
                     (,(symbolicate :assign- name)
                      dst-entity
                      ,@(remove nil
                                (mapcan (lambda (n g)
                                          (unless g
                                            (list (make-keyword n) n)))
                                        slot-names slot-generated-from))))
                    dst-entity))))
            (defmethod replace-component ((index (eql ,index-var-name))
                                          dst-entity src-entity)
              (declare (ignorable index))
              (funcall #',(symbolicate :replace- name) dst-entity src-entity))))
       ,(with-gensyms (entity)
          `(defun ,(symbolicate :reset- name) (,entity)
             ,(format nil "Reset ~a component slot values to their default
values for given ENTITY." name)
             (with-storage ()
               (with-checked-entity ,entity
                 (let* ((component-storages
                          (storage-component-storages storage))
                        (soa (svref component-storages ,index-var-name)))
                   (declare (ignorable soa))
                   (symbol-macrolet
                       (,@(mapcar
                            (lambda (n type)
                              `(,n
                                (aref
                                 (the (simple-array ,type)
                                      (,(symbolicate :% struct-name :- n) soa))
                                 ,entity)))
                            slot-names slot-types))
                     (setf ,@(mapcan #'list slot-names slot-defaults))))))))
       (defmethod reset-component ((index (eql ,index-var-name)) entity)
         ,(format nil "Reset ~a component slot values to their default values
for given ENTITY." name)
         (,(symbolicate :reset- name) entity))
       (defmethod print-component ((index (eql ,index-var-name)) entity
                                   &optional (stream *standard-output*))
         ,(format nil "Prints ~a component data to the given STREAM." name)
         (with-storage ()
           (with-checked-entity entity
             (let* ((component-storages (storage-component-storages storage))
                    (soa (svref component-storages ,index-var-name)))
               (declare (ignorable soa))
               (prin1
                (list
                 ,(make-keyword name)
                 ,@(mapcan (lambda (n type)
                             `(,(make-keyword n)
                               (aref
                                (the (simple-array ,type)
                                     (,(symbolicate :% struct-name :- n) soa))
                                entity)))
                           slot-names slot-types))
                stream)))))
       ,@(remove
          nil
          (mapcar
           (lambda (s type i u)
               (%index-accessor-decls
                name index-var-name struct-name s type i u))
           slot-names slot-types slot-index slot-unique))
       ,(%composite-index-accessor-decls composite-index-name name
                                         composite-index-slots
                                         composite-index-unique
                                         slot-names slot-defaults slot-types)
       (defun ,(symbolicate name :-count) ()
         ,(format
           nil
           "Returns the current count of entities having ~a component."
           name)
         (with-storage ()
           (let* ((component-storages (storage-component-storages storage))
                  (soa (svref component-storages ,index-var-name)))
             (component-soa-count soa))))
       ',name)))

(defmacro define-component (name &rest slots)
  "An alias for `DEFCOMPONENT`."
  `(defcomponent ,name ,@slots))
